unit FtpServerFrm;
{$mode objfpc}{$H+}
interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  LazUTF8, windirs, ExtCtrls, Menus, IdFtpServer, IdFTPListOutput, IdFtpList,
  IdCustomTCPServer, IdContext, windows, registry, IdReply;

type
  { TFtpServerForm }
  TFtpServerForm = class(TForm)
    btnCloseFtp: TButton;
    BtnOpenFtp: TButton;
    BtnDirectory: TButton;
    ChkAnonymous: TCheckBox;
    EdtDirectory: TEdit;
    EdtUser: TEdit;
    EdtPass: TEdit;
    EdtPort: TEdit;
    IdFTPSvr: TIdFTPServer;
    Images: TImageList;
    Label1: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    MiRestore: TMenuItem;
    MenuItem2: TMenuItem;
    MiClose: TMenuItem;
    moNotes: TMemo;
    DirDialog: TSelectDirectoryDialog;
    PanHeader: TPanel;
    PopMenu: TPopupMenu;
    SystrayIcon: TTrayIcon;
    procedure btnCloseFtpClick(Sender: TObject);
    procedure BtnDirectoryClick(Sender: TObject);
    procedure BtnOpenFtpClick(Sender: TObject);
    procedure ChkAnonymousClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
    procedure FormCreate(Sender: TObject);
    procedure IdFTPSvrChangeDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
    procedure IdFTPSvrDeleteFile(ASender: TIdFTPServerContext; const APathName: string);
    procedure IdFTPSvrDisconnect(AContext: TIdContext);
    procedure IdFTPSvrGetFileSize(ASender: TIdFTPServerContext; const AFilename: string; var VFileSize: Int64);
    procedure IdFTPSvrListDirectory(ASender: TIdFTPServerContext; const APath: string; ADirectoryListing: TIdFTPListOutput; const ACmd: String; const ASwitches: String);
    procedure IdFTPSvrMakeDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
    procedure IdFTPSvrRemoveDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
    procedure IdFTPSvrRenameFile(ASender: TIdFTPServerContext; const ARenameFromFile, ARenameToFile: string);
    procedure IdFTPSvrRetrieveFile(ASender: TIdFTPServerContext; const AFileName: string; var VStream: TStream);
    procedure IdFTPSvrStoreFile(ASender: TIdFTPServerContext; const AFileName: string; AAppend: Boolean; var VStream: TStream);
    procedure IdFTPSvrUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var AAuthenticated: Boolean);
    procedure MiRestoreClick(Sender: TObject);
    procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;//此处先声明拦截过程
  private
    EnableClose : Boolean;
    ScreenW, ScreenH : Integer;
    Registry: TRegistry;
  public
    function ReplaceChars(APath: String): String;
    function GetSizeOfFile(AFile : String) : Integer;
  end;

var
  FtpServerForm: TFtpServerForm;

implementation
{$R *.lfm}
{ TFtpServerForm }
procedure TFtpServerForm.FormCreate(Sender: TObject);
begin
  EnableClose := False;
  ScreenW := Screen.Width;
  ScreenH := Screen.Height;
end;

procedure TFtpServerForm.IdFTPSvrChangeDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
begin
  ASender.CurrentDir := VDirectory;
  //moNotes.Append('IdFTPSvrChangeDirectory-->VDirectory: ' + VDirectory);
end;

procedure TFtpServerForm.IdFTPSvrListDirectory(ASender: TIdFTPServerContext;
  const APath: string; ADirectoryListing: TIdFTPListOutput; const ACmd: String;
  const ASwitches: String);
var
 LFTPItem : TIdFTPListItem;
 Info :  SysUtils.TSearchRec;
 SRI : Integer;
 Filter, UpperDir : string;
begin
  ADirectoryListing.DirFormat := doWin32;
  Filter := ReplaceChars(EdtDirectory.Text + APath + '\*.*');
  SRI := FindFirst(Filter, faAnyFile - faHidden - faSysFile, Info);
  While SRI = 0 do
  begin
    LFTPItem := ADirectoryListing.Add;
    LFTPItem.FileName := Info.Name;
    LFTPItem.Size := Info.Size;
    LFTPItem.ModifiedDate := FileDateToDateTime(Info.Time);
    if Info.Attr = faDirectory then
     LFTPItem.ItemType   := ditDirectory
    else
     LFTPItem.ItemType   := ditFile;
    SRI := FindNext(Info);
  end;
  SysUtils.FindClose(Info);
  if not (ReplaceChars(EdtDirectory.Text + APath) = EdtDirectory.Text) then
  begin
    UpperDir := ReplaceChars(EdtDirectory.Text + APath + '\..');
    SetCurrentDir(UpperDir);
  end;
end;

procedure TFtpServerForm.IdFTPSvrMakeDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
begin
  if not ForceDirectories(ReplaceChars(EdtDirectory.Text + '\' + VDirectory)) then
  begin
    //Raise Exception.Create('Unable to create directory');
    moNotes.Append(DateTimeToStr(Now) +#32 + 'Unable to create directory。');
  end;
end;

procedure TFtpServerForm.IdFTPSvrRemoveDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
var
 LFile : String;
begin
  LFile := ReplaceChars(EdtDirectory.Text + '\' + VDirectory + '\');
  // You should delete the directory here.
  DeleteDirectory(LFile, False);
end;

procedure TFtpServerForm.IdFTPSvrRenameFile(ASender: TIdFTPServerContext;
  const ARenameFromFile, ARenameToFile: string);
var
 OldName, NewName: string;
begin
  OldName := ReplaceChars(EdtDirectory.Text  + '\' + ARenameFromFile);
  NewName := ReplaceChars(EdtDirectory.Text + '\' + ARenameToFile);
  RenameFile(OldName, NewName);
end;

procedure TFtpServerForm.IdFTPSvrDeleteFile(ASender: TIdFTPServerContext; const APathName: string);
var
 FileName: string;
begin
  FileName := ReplaceChars(EdtDirectory.Text + '\' + APathname);
  SysUtils.DeleteFile(FileName);
end;

procedure TFtpServerForm.IdFTPSvrDisconnect(AContext: TIdContext);
begin
  moNotes.Append(DateTimeToStr(Now) +#32 + AContext.Binding.PeerIP + ' : 用户退出服务器。');
end;

procedure TFtpServerForm.IdFTPSvrRetrieveFile(ASender: TIdFTPServerContext; const AFileName: string; var VStream: TStream);
begin
  VStream := TFileStream.Create(ReplaceChars(EdtDirectory.Text + '\' + AFilename), fmOpenRead);
end;

procedure TFtpServerForm.IdFTPSvrStoreFile(ASender: TIdFTPServerContext; const AFileName: string; AAppend: Boolean; var VStream: TStream);
begin
  if not Aappend then
  begin
    VStream := TFileStream.Create(ReplaceChars(EdtDirectory.Text + '\' + AFilename), fmCreate)
  end
  else
    VStream := TFileStream.Create(ReplaceChars(EdtDirectory.Text + '\' + AFilename), fmOpenWrite);
end;

procedure TFtpServerForm.IdFTPSvrUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var AAuthenticated: Boolean);
begin
  // We just set AAuthenticated to true so any username / password is accepted
  // You should check them here - AUsername and APassword
  if ChkAnonymous.Checked then
  begin
     AAuthenticated := True;
     moNotes.Append(DateTimeToStr(Now) +#32 + ASender.Binding.PeerIP + ' : 匿名登录服务器成功。');
  end else
  if (AUsername=EdtUser.Text) and (APassword=EdtPass.Text) then
  begin
    AAuthenticated := True;
    moNotes.Append(DateTimeToStr(Now) +#32 + ASender.Binding.PeerIP + ' : 用户登录服务器成功。');
  end else
  begin
     AAuthenticated := False;
     moNotes.Append(DateTimeToStr(Now) +#32 + ASender.Binding.PeerIP + ' : 尝试登录服务器失败。');
  end;
end;

procedure TFtpServerForm.MiRestoreClick(Sender: TObject);
begin
  WindowState := wsNormal;
  Self.Show;
  Self.Left := (ScreenW - Self.Width) div 2;
  Self.Top  := (ScreenH - Self.Height) div 2;
end;

function TFtpServerForm.ReplaceChars(APath: String): String;
var
 s:string;
begin
  s := StringReplace(APath, '/', '\', [rfReplaceAll]);
  s := StringReplace(s, '\\\', '\', [rfReplaceAll]);
  s := StringReplace(s, '\\', '\', [rfReplaceAll]);
  Result := s;
end;

function TFtpServerForm.GetSizeOfFile(AFile: String): Integer;
var
  FStream : TFileStream;
begin
  try
    FStream := TFileStream.Create(AFile, fmOpenRead);
    try
      Result := FStream.Size;
    finally
      FreeAndNil(FStream);
    end;
  except
     Result := 0;
  end;
end;

procedure TFtpServerForm.IdFTPSvrGetFileSize(ASender: TIdFTPServerContext; const AFilename: string; var VFileSize: Int64);
var
 LFile : String;
begin
  LFile := ReplaceChars( EdtDirectory.Text + AFilename );
  try
   if FileExists(LFile) then
     VFileSize :=  GetSizeOfFile(LFile)
   else
     VFileSize := 0;
  except
    VFileSize := 0;
  end;
end;

procedure TFtpServerForm.WMSysCommand(var Msg: TWMSysCommand);
begin
  //ShowMessage(IntToStr(Msg.CmdType)); //61536
  if (Msg.CmdType=SC_CLOSE) then
  begin
    WindowState := wsMinimized;
    Self.Hide;
  end else
  inherited;
end;

procedure TFtpServerForm.btnCloseFtpClick(Sender: TObject);
begin
  Registry.WriteString('Directory',EdtDirectory.Text);
  Registry.WriteString('UserName',EdtUser.Text);
  Registry.WriteString('PassWord',EdtPass.Text);
  if ChkAnonymous.Checked then Registry.WriteInteger('Anonymous',1) else Registry.WriteInteger('Anonymous',0);
  Registry.WriteInteger('DefaultPort', StrToIntDef(EdtPort.Text,21));
  EnableClose := True;
  Close;
end;

procedure TFtpServerForm.BtnDirectoryClick(Sender: TObject);
begin
  if DirDialog.Execute then
  begin
    EdtDirectory.Text := DirDialog.FileName;
  end;
end;

procedure TFtpServerForm.BtnOpenFtpClick(Sender: TObject);
begin
  IdFTPSvr.Active := False;
  IdFTPSvr.DefaultDataPort := StrToIntDef(EdtPort.Text,21);
  IdFTPSvr.AllowAnonymousLogin := ChkAnonymous.Checked;
  IdFTPSvr.Active := True;
  //
  moNotes.Append(DateTimeToStr(Now)+#32 +'FTP服务器已经开启。');
end;

procedure TFtpServerForm.ChkAnonymousClick(Sender: TObject);
begin
  EdtUser.Enabled := not ChkAnonymous.Checked;
  EdtPass.Enabled := not ChkAnonymous.Checked;
  IdFTPSvr.AllowAnonymousLogin := ChkAnonymous.Checked;
end;

procedure TFtpServerForm.FormActivate(Sender: TObject);
begin
  EdtDirectory.Text := GetWindowsSpecialDir(CSIDL_DESKTOPDIRECTORY, False);
  //
  Registry := TRegistry.Create;
  Registry.RootKey := HKEY_CURRENT_USER;
  Registry.OpenKey('Software', False);
  if Registry.OpenKey('FtpServer', True) then
  begin
    if Registry.ValueExists('Directory') then
      EdtDirectory.Text := Registry.ReadString('Directory')
    else
      Registry.WriteString('Directory',EdtDirectory.Text);
    // --------
    if Registry.ValueExists('UserName') then
      EdtUser.Text := Registry.ReadString('UserName')
    else
      Registry.WriteString('UserName',EdtUser.Text);
    // --------
    if Registry.ValueExists('PassWord') then
      EdtPass.Text := Registry.ReadString('PassWord')
    else
      Registry.WriteString('PassWord',EdtPass.Text);
    // --------
    if Registry.ValueExists('Anonymous') then
      ChkAnonymous.Checked := (0<>Registry.ReadInteger('Anonymous'))
    else
      if ChkAnonymous.Checked then Registry.WriteInteger('Anonymous', 1) else Registry.WriteInteger('Anonymous', 0);
   // --------
    if Registry.ValueExists('DefaultPort') then
      EdtPort.Text := IntToStr(Registry.ReadInteger('DefaultPort'))
    else
     Registry.WriteInteger('DefaultPort', StrToIntDef(EdtPort.Text,21));
  end;
  //
  ChkAnonymousClick(Sender);
  BtnOpenFtpClick(Sender);
  Self.Hide;
  WindowState := wsMinimized;
  SystrayIcon.Show;
end;

procedure TFtpServerForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  IdFTPSvr.Active := False;
  CloseAction := caFree;
end;

procedure TFtpServerForm.FormCloseQuery(Sender: TObject; var CanClose: boolean);
begin
  CanClose := EnableClose;
end;

end.

